home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
basic.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-10-06
|
6KB
|
260 lines
/* ******************************************************************** */
/* basic.c Copyright (C) Codemist and University of Bath 1989 */
/* */
/* Basic functions */
/* ******************************************************************** */
/*
* Change Log:
* Version 1, April 1989
* Add many functions - JPff
* Add rplaca & rplacd - RJB
* Add defmacro - JPff
* Introduce GC protection in places - JPff
* Wrote NREVERSE for fun - JPff
* and ASSOC - JPff
* Moved basic.c to generic.c - JPff
* Add defconstant and mutability in bindings - JPff
* Hacked car & cons on the nil case and fixed the consp
* make_module_function so that it didn't refer to cons !! - (25/10/89) KJP
* Altered defun so that its body is a list of forms - (25/10/89) KJP
*/
#include "defs.h"
#include "structs.h"
#include "funcalls.h"
#include "error.h"
#include "global.h"
#include "modboot.h"
#include "specials.h"
EUFUN_1( Fn_atom, form)
{
return (is_cons(form) ? nil : lisptrue);
}
EUFUN_CLOSE
void printoblist(LispObject *stacktop)
{ /* Broke */
LispObject ob = (LispObject) ObList;
while (ob!=NULL) {
EUCALL_2(Fn_print,ob, StdErr);
ob = (LispObject) (ob->SYMBOL).left;
}
}
EUFUN_0 (Fn_oblist)
{
printoblist(stacktop);
return nil;
}
EUFUN_CLOSE
EUFUN_1( Fn_consn, n)
{
int i;
LispObject l = nil;
for (i = intval(n); i > 0; --i) {
ARG_1(stacktop) = l;
ARG_0(stacktop) = nil;
l = Fn_cons(stacktop);
}
return(l);
}
EUFUN_CLOSE
EUFUN_1( Fn_system, str)
{
extern int system(char *);
if (!is_string(str))
CallError(stacktop,"system: not a string",str,NONCONTINUABLE);
(void) system(stringof(str));
return(nil);
}
EUFUN_CLOSE
EUFUN_1( Fn_getenv, str)
{
extern char *getenv(char *);
extern int strlen(char *);
char *value;
if (!is_string(str))
CallError(stacktop,"getenv: not a string",str,NONCONTINUABLE);
value = getenv(stringof(str));
if (value == NULL) return(nil);
return((LispObject) allocate_string(stacktop,value,strlen(value)));
}
EUFUN_CLOSE
EUFUN_0( Fn_exit)
{
fprintf(StdOut->STREAM.handle,"\n\nExiting EuLisp\n\n");
exit(0);
return(nil);
}
EUFUN_CLOSE
EUFUN_0( Fn_make_map)
{
extern void make_map(void);
make_map();
return(nil);
}
EUFUN_CLOSE
/* Time... */
#include <sys/types.h>
EUFUN_0( Fn_system_time)
{
extern long time(long *);
long n;
(void) time(&n);
return(allocate_integer(stackbase, (int) n));
}
EUFUN_CLOSE
EUFUN_0( Fn_process_id)
{
extern int getpid(void);
return(allocate_integer(stackbase, getpid()));
}
EUFUN_CLOSE
EUFUN_0( Fn_backtrace)
{
extern void module_eval_backtrace(void);
module_eval_backtrace();
return(nil);
}
EUFUN_CLOSE
EUFUN_0( Fn_cpu_time)
{
extern long clock(void);
return(allocate_integer(stackbase, (int)(clock()/10000)));
}
EUFUN_CLOSE
EUFUN_0( Fn_rand)
{
extern int rand(void);
return(allocate_integer(stackbase, rand()));
}
EUFUN_CLOSE
EUFUN_1( Fn_srand, s)
{
extern void srand(unsigned int);
srand((unsigned int) intval(s));
return(nil);
}
EUFUN_CLOSE
EUFUN_1( Fn_system_describe, obj)
{
printf("Address: %x\n",(int) obj);
printf("Type: %x\n",typeof(obj));
printf("GC: %x\n",gcof(obj));
printf("Class: %x\n",(int) classof(obj));
fflush(stdout);
return(nil);
}
EUFUN_CLOSE
/* Weak pointers... */
extern LispObject allocate_weak_wrapper(LispObject*, LispObject);
EUFUN_1( Fn_make_weak_wrapper, obj)
{
return(allocate_weak_wrapper(stackbase, obj));
}
EUFUN_CLOSE
EUFUN_1( Fn_weak_wrapper_ref, w)
{
if (!is_weak_wrapper(w))
CallError(stacktop,
"weak-wrapper-ref: not a weak wrapper",w,NONCONTINUABLE);
return(w->WEAK_WRAPPER.object);
}
EUFUN_CLOSE
EUFUN_2 (Fn_weak_wrapper_ref_setter, w, obj)
{
if (!is_weak_wrapper(w))
CallError(stacktop,"(setter weak-wrapper-ref): not a weak wrapper",
w,NONCONTINUABLE);
w->WEAK_WRAPPER.object = obj;
return(obj);
}
EUFUN_CLOSE
/* *************************************************************** */
/* Initialisation of this section */
/* *************************************************************** */
void initialise_basic(LispObject *stacktop)
{
LispObject get,set;
(void) make_module_function(stacktop,"special-operator-p",Fn_special_form_p,1);
get = make_module_function(stacktop,"symbol-dynamic-value",Fn_dynamic,1);
STACK_TMP(get);
set = make_unexported_module_function(stacktop,"symbol-dynamic-value-updator",
Fn_dynamic_setq,2);
UNSTACK_TMP(get);
set_anon_associate(stacktop,get,set);
(void) make_module_function(stacktop,"atom",Fn_atom,1);
(void) make_module_function(stacktop,"oblist", Fn_oblist, 0);
(void) make_module_function(stacktop,"consn", Fn_consn, 1);
(void) make_module_function(stacktop,"system",Fn_system,1);
(void) make_module_function(stacktop,"getenv",Fn_getenv,1);
(void) make_module_function(stacktop,"exit",Fn_exit,0);
(void) make_module_function(stacktop,"make-map",Fn_make_map,0);
(void) make_module_function(stacktop,"system-time",Fn_system_time,0);
(void) make_module_function(stacktop,"process-id",Fn_process_id,0);
(void) make_module_function(stacktop,"backtrace",Fn_backtrace,0);
(void) make_module_function(stacktop,"cpu-time",Fn_cpu_time,0);
(void) make_module_function(stacktop,"c-rand",Fn_rand,0);
(void) make_module_function(stacktop,"c-srand",Fn_srand,1);
(void) make_module_function(stacktop,"system-print",Fn_system_describe,1);
(void) make_module_function(stacktop,"make-weak-wrapper",Fn_make_weak_wrapper,1);
get = make_module_function(stacktop,"weak-wrapper-ref",Fn_weak_wrapper_ref,1);
STACK_TMP(get);
set = make_module_function(stacktop,"(setter weak-wrapper-ref)",
Fn_weak_wrapper_ref_setter,2);
UNSTACK_TMP(get);
set_anon_associate(stacktop,get,set);
}